VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "TrappableErrorHandler"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Implements IErrorListener

Private CM_GLOBALMETHODS

Private vm_MethodCallStack As Stack

Private vm_LastError As ErrorNode
Private vm_FirstError As ErrorNode

Private vm_ErrorClasses As Collection
Private vm_ErrorMethods As Collection


Private vm_ClassRegistrationListeners As ListenerQueue
Private vm_MethodRegistrationListeners As ListenerQueue
Private vm_ErrorRegistrationListeners As ListenerQueue

Private vm_OperationsListeners As ListenerQueue



Private Sub Class_Initialize()
If vp_CallStackSessions Is Nothing Then Set vp_CallStackSessions = New CallStackSessionManager
Set vm_MethodCallStack = vp_CallStackSessions.createSession

Set vm_ErrorClasses = New Collection
Set vm_ErrorMethods = New Collection
Set vm_OperationsListeners = New ListenerQueue
Set vm_ClassRegistrationListeners = New ListenerQueue
Set vm_MethodRegistrationListeners = New ListenerQueue
Set vm_ErrorRegistrationListeners = New ListenerQueue
End Sub

Private Sub Class_Terminate()

vp_CallStackSessions.terminateSession vm_MethodCallStack
If vp_CallStackSessions.numItems = 0 Then Set vp_CallStackSessions = Nothing

Set vm_ErrorClasses = Nothing
Set vm_ErrorMethods = Nothing
Set vm_OperationsListeners = Nothing
Set vm_MethodRegistrationListeners = Nothing
Set vm_ErrorRegistrationListeners = Nothing
Set vm_ClassRegistrationListeners = Nothing
End Sub

Public Sub displayErrors()
Dim vl_Cancel As CancelArg
Dim vl_DataToDisplay As DataToDisplay

Dim vl_Error As String
Dim vl_ErrorResults As VbMsgBoxResult


Set vl_Cancel = New CancelArg
Set vl_DataToDisplay = New DataToDisplay

With vl_DataToDisplay
    
End With

invokeOperationsListeners vm_OperationsListeners, olmBeforeDisplayErrorsCancel, vl_DataToDisplay, vl_Cancel
If vl_Cancel = True Then GoTo cleanUp


 vl_Error = "An error has occured in the " & Me.firstError.faultMethod.methodName & " method" & _
        IIf(Me.firstError.faultLine > 0, " at line " & Me.firstError.faultLine, vbNullString) & "." & _
        vbCrLf & vbCrLf & buildErrorDescription(Me.lastError) & vbCrLf & vbCrLf & _
        Me.firstError.stackTrace & vbCrLf & vbCrLf & _
        "Do you want to terminate the program?" & _
        vbCrLf & vbTab & "If you click no, errors may be produced during use." & _
        vbCrLf & vbTab & "If you click yes, the program will terminate and data may not be saved."


vl_ErrorResults = MsgBox(vl_Error, vbYesNo, "Error")
If vl_ErrorResults = vbYes Then
    invokeOperationsListeners vm_OperationsListeners, olmAfterDisplayEndProgram, vl_DataToDisplay
Else
    invokeOperationsListeners vm_OperationsListeners, olmAfterDisplayContinueProgram, vl_DataToDisplay
End If

cleanUp:
End Sub



Private Function buildErrorDescription(ByVal pr_ErrorObject As ErrorNode) As String
Dim vl_String As String

If pr_ErrorObject Is Nothing Then Exit Function

vl_String = pr_ErrorObject.description & vbCrLf & buildErrorDescription(pr_ErrorObject.innerError)

buildErrorDescription = vl_String
End Function








Public Sub displayErrorsAndClear()
displayErrors
clearErrors
End Sub

Public Function errorExists() As Boolean
errorExists = Not lastError Is Nothing
End Function

Public Sub clearErrors()
invokeErrorListeners vm_ErrorRegistrationListeners, elmErrorCleared, vm_LastError
Set vm_FirstError = Nothing
Set lastError = Nothing
End Sub

Public Property Get activeClasses() As Collection
Set activeClasses = vm_ErrorClasses
End Property

Public Property Get activeMethods() As Collection
Set activeMethods = vm_ErrorMethods
End Property

Public Property Get lastError() As ErrorNode
Set lastError = vm_LastError
End Property

Friend Property Set lastError(ByVal pr_NewNode As ErrorNode)
If vm_LastError Is Nothing Then
    Set vm_FirstError = pr_NewNode
End If

If pr_NewNode Is Nothing Then
    Set vm_FirstError = Nothing
End If

Set vm_LastError = pr_NewNode
End Property


Public Property Get firstError() As ErrorNode
Set firstError = vm_FirstError
End Property

Public Property Get callStack() As String
callStack = traceStringStackUsingDelimiter(vm_MethodCallStack.getReversedStack, ">")
End Property



Public Function createNewChildErrorClass(className As String) As ErrorClass
Dim vl_newClass As ErrorClass

Set vl_newClass = New ErrorClass
vl_newClass.init className, Me


Set createNewChildErrorClass = vl_newClass
End Function

Public Function hasErrorClassByName(errorClassName As String) As Boolean
If getErrorClassByName(errorClassName) Is Nothing Then errorClassName = False Else errorClassName = True
End Function

Public Function getErrorClassByName(errorClassName As String) As ErrorClass
Dim vl_ErrorClassObject As ErrorClass
checkAndHandleEmptyString errorClassName

'The most common (and only) error that we will get here is error #5 - invalid procedure call or argument.
'in that case, we want the method to reutrn nothing, so we are simply moving to the next statement
If objectExistsInCollectionByIndex(vm_ErrorClasses, errorClassName) Then
    Set vl_ErrorClassObject = vm_ErrorClasses.Item(errorClassName)
End If
Set getErrorClassByName = vl_ErrorClassObject
End Function

Friend Sub registerErrorClassByObject(ByVal classToRegister As ErrorClass)
registerErrorObjectAndInvokeListeners classToRegister, rltClass
End Sub

Public Function unregisterAndReturnErrorClassByName(errorClassName As String) As ErrorClass
Set unregisterAndReturnErrorClassByName = unregisterAndReturnErrorObjectByName(rltClass, errorClassName)
End Function

Public Sub unregisterErrorClassByObject(ByVal errorClassObject As ErrorClass)
unregisterErrorObject errorClassObject
End Sub

Public Function createNewChildErrorHandler() As TrappableErrorHandler
Dim vl_NewHandler As TrappableErrorHandler

Set vl_NewHandler = New TrappableErrorHandler

vl_NewHandler.addErrorRegistrationSystemListener Me
'vl_NewHandler.addErrorRegistrationSystemListener Me
'TODO Add some communications for this errorhandler to know when the child is terminated

Set createNewChildErrorHandler = vl_NewHandler
End Function

Public Function createNewChildErrorMethod(methodName As String, ByVal pr_ParentClass As ErrorClass) As ErrorMethod
Dim vl_newMethod As ErrorMethod
checkAndHandleEmptyString methodName

Set vl_newMethod = New ErrorMethod
vl_newMethod.init methodName, pr_ParentClass, Me

Set createNewChildErrorMethod = vl_newMethod
End Function

Public Function getErrorMethodByName(errorMethodName As String) As ErrorMethod
Dim vl_ErrorMethodObject As ErrorMethod
checkAndHandleEmptyString errorMethodName

If objectExistsInCollectionByIndex(vm_ErrorMethods, errorMethodName) Then
    Set vl_ErrorMethodObject = vm_ErrorMethods.Item(errorMethodName)
End If
Set getErrorMethodByName = vl_ErrorMethodObject
End Function

Public Function hasErrorMethodByName(errorMethodName As String) As Boolean
If getErrorMethodByName(errorMethodName) Is Nothing Then hasErrorMethodByName = False Else hasErrorMethodByName = True
End Function

Friend Sub registerErrorMethodByObject(ByVal method As ErrorMethod)
registerErrorObjectAndInvokeListeners method, rltMethod
method.addErrorSystemListener Me
If method.parentClass Is Nothing Then
    vm_MethodCallStack.push "GLOBAL." & method.methodName
Else
    vm_MethodCallStack.push method.parentClass.className & "." & method.methodName
End If
End Sub

Public Function unregisterAndReturnErrorMethodByName(errorMethodName As String) As ErrorMethod
Set unregisterAndReturnErrorMethodByName = unregisterAndReturnErrorObjectByName(rltMethod, errorMethodName)
vm_MethodCallStack.pop
End Function

Public Sub unregisterErrorMethodByObject(ByVal pr_ErrorMethod As ErrorMethod)
unregisterErrorObject pr_ErrorMethod
vm_MethodCallStack.pop
End Sub


Private Function registerErrorObjectAndInvokeListeners(ByVal pr_Object As Object, _
        pr_ObjectType As RegistrationListenerTypes)
Dim vl_ListenerCollection As ListenerQueue
Dim vl_RegistrationCollection As Collection
Dim vl_Cancel As CancelArg

Set vl_Cancel = New CancelArg

Set vl_ListenerCollection = getListenerCollection(pr_ObjectType)
Set vl_RegistrationCollection = getRegistrationCollection(pr_ObjectType)

If Not objectExistsInCollectionByIndex(vl_RegistrationCollection, getErrorObjectName(pr_Object)) Then
    invokeRegistrationListeners vl_ListenerCollection, pr_ObjectType, rlmBeforeAdded, pr_Object, vl_Cancel
    If vl_Cancel Then Exit Function
    vl_RegistrationCollection.Add pr_Object, getErrorObjectName(pr_Object)
    invokeRegistrationListeners vl_ListenerCollection, pr_ObjectType, rlmAfterAddded, pr_Object
End If

End Function

Friend Function getRegistrationCollection(pr_ObjectType As RegistrationListenerTypes) As Collection
Select Case pr_ObjectType
Case rltClass
    Set getRegistrationCollection = vm_ErrorClasses
Case rltMethod
    Set getRegistrationCollection = vm_ErrorMethods
End Select
End Function

Friend Function getListenerCollection(pr_ObjectType As RegistrationListenerTypes) As ListenerQueue
Select Case pr_ObjectType
Case rltClass
    Set getListenerCollection = vm_ClassRegistrationListeners
Case rltMethod
    Set getListenerCollection = vm_MethodRegistrationListeners
End Select
End Function

Friend Function getErrorObjectName(ByVal pr_ErrorObject As Object) As String
Dim vl_ObjectName As String

If TypeOf pr_ErrorObject Is ErrorMethod Then
    vl_ObjectName = pr_ErrorObject.methodName
Else
    If TypeOf pr_ErrorObject Is ErrorClass Then
        vl_ObjectName = pr_ErrorObject.className
    Else
        Err.Raise CP_ERROR_OBJECTNOTVALID, Me, CP_ERROR_OBJECTNOTVALID_DESC
        GoTo cleanUp
    End If
End If

cleanUp:
getErrorObjectName = vl_ObjectName
End Function

Private Function unregisterAndReturnErrorObjectByName(errorObjectType As RegistrationListenerTypes, errorObjectName As String) As Object
Dim vl_FoundClass As Object

checkAndHandleEmptyString errorObjectName

Set vl_FoundClass = getErrorObjectByName(errorObjectType, errorObjectName)
If Not (vl_FoundClass Is Nothing) Then
    unregisterErrorObject vl_FoundClass
End If

Set unregisterAndReturnErrorObjectByName = vl_FoundClass
End Function

Private Function getErrorObjectByName(pr_ObjectType As RegistrationListenerTypes, errorObjectName As String) As Object
Select Case pr_ObjectType
Case rltClass
    Set getErrorObjectByName = getErrorClassByName(errorObjectName)
Case rltMethod
    Set getErrorObjectByName = getErrorMethodByName(errorObjectName)
End Select
End Function

Private Function unregisterErrorObject(ByVal pr_Object As Object)
Dim i As Integer
Dim vl_RemovalSuccess As Boolean
Dim vl_RegisteredErrorObjects As Collection

Set vl_RegisteredErrorObjects = getRegistrationCollection(getRegListenerTypeFromObject(pr_Object))

For i = 1 To vl_RegisteredErrorObjects.Count
    If pr_Object Is vl_RegisteredErrorObjects(i) Then
        vl_RemovalSuccess = invokeErrorObjectRemovalAndReturnSuccess(i, pr_Object)
        Exit For
    End If
Next i
End Function


Private Function invokeErrorObjectRemovalAndReturnSuccess(ByVal pr_ErrorCollectionKey As String, ByVal pr_ItemToRemove As Object) As Boolean
Dim vl_ObjectType As RegistrationListenerTypes
Dim vl_RegistrationCollection As Collection
Dim vl_ListenerCollection As ListenerQueue
Dim vl_Cancelled As CancelArg

Set vl_Cancelled = New CancelArg

vl_ObjectType = getRegListenerTypeFromObject(pr_ItemToRemove)
Set vl_RegistrationCollection = getRegistrationCollection(vl_ObjectType)
Set vl_ListenerCollection = getListenerCollection(vl_ObjectType)

If objectExistsInCollectionByIndex(vl_RegistrationCollection, pr_ErrorCollectionKey) Then
    invokeRegistrationListeners vl_ListenerCollection, vl_ObjectType, rlmBeforeRemoved, pr_ItemToRemove, vl_Cancelled
    If vl_Cancelled Then Exit Function
    vl_RegistrationCollection.Remove pr_ErrorCollectionKey
    invokeRegistrationListeners vl_ListenerCollection, vl_ObjectType, rlmAfterRemoved, pr_ItemToRemove
End If

invokeErrorObjectRemovalAndReturnSuccess = Not vl_Cancelled
End Function





Friend Sub addClassRegistrationSystemListener(ByVal listener As IErrorClassRegListener)
checkAndHandleNonInitializedObject listener

vm_ClassRegistrationListeners.enqueueToQueue listener, qtSystem
End Sub

Public Sub addClassRegistrationListener(ByVal listener As IErrorClassRegListener)
checkAndHandleNonInitializedObject listener

vm_ClassRegistrationListeners.enqueueToQueue listener, qtExternal
End Sub

Public Sub removeClassRegistrationListener(ByVal listener As IErrorClassRegListener)
checkAndHandleNonInitializedObject listener

vm_ClassRegistrationListeners.removeElementAndReturnSuccess listener
End Sub

Public Function hasClassRegistrationListener(ByVal listener As IErrorClassRegListener) As Boolean
checkAndHandleNonInitializedObject listener

hasClassRegistrationListener = vm_ClassRegistrationListeners.hasElement(listener)
End Function

Friend Sub addMethodRegistrationSystemListener(ByVal errorMethodlistener As IErrorMethodRegListener)
checkAndHandleNonInitializedObject errorMethodlistener

vm_MethodRegistrationListeners.enqueueToQueue errorMethodlistener, qtSystem
End Sub

Public Sub addMethodRegistrationListener(ByVal errorMethodlistener As IErrorMethodRegListener)
checkAndHandleNonInitializedObject errorMethodlistener

vm_MethodRegistrationListeners.enqueueToQueue errorMethodlistener, qtExternal
End Sub

Public Sub removeMethodRegistrationListener(ByVal errorMethodlistener As IErrorClassRegListener)
checkAndHandleNonInitializedObject errorMethodlistener

vm_MethodRegistrationListeners.removeElementAndReturnSuccess errorMethodlistener
End Sub

Public Function hasMethodRegistrationListener(ByVal listener As IErrorClassRegListener)
checkAndHandleNonInitializedObject listener

hasMethodRegistrationListener = vm_MethodRegistrationListeners.hasElement(listener)
End Function

Public Sub addOperationsListener(ByVal listener As IErrorOpsCallback)
checkAndHandleNonInitializedObject listener
 
vm_OperationsListeners.enqueueToQueue listener, qtExternal
End Sub

Friend Sub addOperationsSystemListener(ByVal listener As IErrorOpsCallback)
checkAndHandleNonInitializedObject listener

vm_OperationsListeners.enqueueToQueue listener, qtSystem
End Sub

Public Sub removeOperationsRegistrationListener(ByVal listener As IErrorOpsCallback)
checkAndHandleNonInitializedObject listener

vm_OperationsListeners.removeElementAndReturnSuccess listener
End Sub

Public Function hasOperationsRegistrationListener(ByVal listener As IErrorOpsCallback) As Boolean
hasOperationsRegistrationListener = vm_OperationsListeners.hasElement(listener)
End Function

Friend Sub addErrorRegistrationSystemListener(ByVal listener As IErrorListener)
checkAndHandleNonInitializedObject listener

vm_ErrorRegistrationListeners.enqueueToQueue listener, qtSystem
End Sub

Public Sub addErrorRegistrationListener(ByVal listener As IErrorListener)
checkAndHandleNonInitializedObject listener

vm_ErrorRegistrationListeners.enqueueToQueue listener, qtExternal
End Sub

Public Sub removeErrorRegistrationListener(ByVal listener As IErrorListener)
checkAndHandleNonInitializedObject listener

vm_ErrorRegistrationListeners.removeElementAndReturnSuccess listener
End Sub

Public Function hasErrorRegistrationListener(ByVal listener As IErrorListener) As Boolean
checkAndHandleNonInitializedObject listener


hasErrorRegistrationListener = vm_ErrorRegistrationListeners.hasElement(listener)
End Function



'ERROR MESSAGES RECEIVED BY CALLBACKS/INTERFACES
Private Sub IErrorListener_errorAdded(ByVal newError As ErrorNode)
Dim vl_Cancel As CancelArg
Set vl_Cancel = New CancelArg

checkAndHandleNonInitializedObject newError


With newError
    Set .innerError = lastError
    
    If Me Is .faultMethod.parentHandler Then
        .stackTrace = Me.callStack & IIf(newError.faultLine <> 0, ":" & newError.faultLine, vbNullString)
    Else
        .stackTrace = Me.callStack & ">" & .faultMethod.parentHandler.callStack & IIf(newError.faultLine <> 0, ":" & newError.faultLine, vbNullString)
    End If
    
End With


invokeOperationsListeners vm_OperationsListeners, olmBeforePushErrorStack, newError, vl_Cancel
'TODO: Figure out how to do callbyname and centralized methods
'perhaps a method for each event? blargh...
If vl_Cancel Then GoTo cleanUp
Set lastError = newError

invokeErrorListeners vm_ErrorRegistrationListeners, elmErrorAdded, newError

cleanUp:
End Sub

Private Sub IErrorListener_errorCleared(ByVal pr_firstError As ErrorNode)
checkAndHandleNonInitializedObject pr_firstError

invokeErrorListeners vm_ErrorRegistrationListeners, elmErrorCleared, pr_firstError
End Sub
